Celestin Apprentice 2/Apprentice-Release2.iso/Tools/Languages/MacHaskell 2.2/import-export/init-modules.scm

Text File | 1994-09-27 | 5.2 KB | 146 lines | [TEXT/CCL2]

;;; This initializes the module ast structures.

;;; This requires that the module table be created and updated with new
;;; modules first.  *unit* must also be defined.

;;; Things initialized there:
;;;  all tables in the module structure
;;;  the module slot of all import declarations and entity-modules
;;;  The import Prelude is added when necessary
;;;  Empty export lists are explicated

(define (init-module-structure)
  (when (not (eq? (module-type *module*) 'extension))
    ;; If this is an extension, the incremental compiler has already
    ;; filled in the compilation unit.
    (setf (module-unit *module*) *unit*))
  ;;; This processes the annotations.  Annotations used at the top
  ;;; level of the module:
  ;;;   {-#PRELUDE#-} : this contains definitions in the Haskell prelude
  (setf (module-prelude? *module*) '#f)
  (dolist (a (module-annotations *module*))
    (when (annotation-value? a)
      (let ((name (annotation-value-name a)))
    (cond ((eq? name '|Prelude|)
           (setf (module-prelude? *module*) '#t))))))
  (cond ((eq? (module-type *module*) 'interface)
     (setf (module-exported-modules *module*) (list *module*))
     (process-interface-imports *module*))
    ((eq? (module-type *module*) 'standard)
     (init-standard-module))))

(define (init-standard-module)
   (let ((seen-prelude? '#f)
     (imports1 '())) ; used to filter out bad imports
    (dolist (import (module-imports *module*))
      (let* ((name (import-decl-module-name import))
         (imported-mod (locate-module name)))
    (when (eq? name '|Prelude|)
       (setf seen-prelude? '#t))
    (cond ((eq? imported-mod '#f)
           (signal-undefined-module-import name))
          ((eq? name *module-name*)
           (signal-self-import name))
          (else
           (setf (import-decl-module import) imported-mod)
           (push import imports1)))))
    (setf (module-imports *module*) imports1)
    (when (null? (module-exports *module*))
    (setf (module-exports *module*)
          (list (make entity-module (name *module-name*)
                            (module *module*)))))
    (when (not seen-prelude?)
      (let ((prelude (locate-module '|Prelude|)))
    (cond ((eq? prelude '#f)
           (signal-missing-prelude))
          ((module-prelude? *module*)
           (setf (module-uses-standard-prelude? *module*) '#f)
           (add-imported-module prelude))
          (else
           (setf (module-uses-standard-prelude? *module*) '#t)
           (let ((fix-table (module-fixity-table *module*)))
         (table-for-each (lambda (k v)
                   (setf (table-entry fix-table k) v))
                 *prelude-fixity-table*))))))
    (let ((prelude-core (locate-module '|PreludeCore|)))
       (if (eq? prelude-core '#f)
       (signal-missing-prelude-core)
       (when (module-prelude? *module*)
         (add-imported-module prelude-core))))
    (setf (module-exports *module*)
      (filter-complete-module-exports (module-exports *module*))))
    )


(define (add-imported-module module)
  (setf (module-imports *module*)
    (cons (make import-decl
            (module-name (module-name module))
            (module module)
            (mode 'all)
            (specs '())
            (renamings '()))
          (module-imports *module*))))

(define (filter-complete-module-exports exports)
  (if (null? exports)
      '()
      (let ((export (car exports))
        (others (filter-complete-module-exports (cdr exports))))
    (if (is-type? 'entity-module export)
        (let* ((name (entity-name export))
           (exported-mod (locate-module name)))
          (cond ((not (memq name
                (cons *module-name*
                      (map
                       (lambda (import)
                     (import-decl-module-name import))
                       (module-imports *module*)))))
             (signal-export-not-imported name))
            ((not (eq? exported-mod '#f))
             (push exported-mod (module-exported-modules *module*))))
          others)
        (cons export others)))))

(define (process-interface-imports module)
  (let ((imports '()))
    (dolist (i (module-imports module))
      (let ((module (import-decl-module-name i))
        (renamings (import-decl-renamings i)))
    (dolist (s (import-decl-specs i))
          (let* ((n (entity-name s))
         (n1 (do-interface-rename n renamings)))
        (when (assq n1 imports)
               (signal-multiple-imports n1))
        (push (tuple n1 (tuple module n)) imports)
        (cond ((entity-class? s)
           (dolist (m (entity-class-methods s))
                     (let ((m1 (do-interface-rename m renamings)))
               (when (assq m1 imports)
                          (signal-multiple-imports m1))
               (push (tuple m1 (tuple module m)) imports))))
          ((entity-datatype? s)
           (dolist (m (entity-datatype-constructors s))
                     (let ((m1 (do-interface-rename m renamings)))
               (when (assq m1 imports)
                          (signal-multiple-imports m1))
               (push (tuple m1 (tuple module m)) imports)))))))))
    (setf (module-interface-imports module) imports)))

(define (signal-multiple-imports name)
  (phase-error 'multuple-interface-import
    "Interface file has more than one definition of ~A~%" name))

(define (do-interface-rename name renamings)
  (if (has-con-prefix? (symbol->string name))
      (let ((res (locate-renaming name renamings)))
    (if (eq? res '#f)
        name
        (renaming-to res)))
      (let* ((n1 (add-con-prefix/symbol name))
         (res (locate-renaming n1 renamings)))
    (if (eq? res '#f)
        name
        (remove-con-prefix/symbol (renaming-to res))))))